home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / yerk / mps231ss.hqx / Mops source / System source / Neon Compatibility < prev    next >
Text File  |  1993-02-20  |  9KB  |  345 lines
  1. \ Neonâ•©compatibility
  2. \ This file is aimed at helping the transition from Neon to Mops.
  3.  
  4. false -> Neon?
  5.  
  6. need dialog
  7. need alertq
  8.  
  9. \ Only include those lines when you use dialogs or alert" respectively.
  10.  
  11. true -> Neon?
  12.  
  13. \ ( b -- bool )  make a Forth boolean into a Toolbox boolean
  14. \ neither mops nor neon sensitive
  15. : Bool    if $ 100 else 0 then makeInt ;
  16.  
  17. \ Words involving the loop counter i.  We don't need these in Mops
  18. \ since e.g.  i @   compiles exactly the same code as  i@  would, due
  19. \ to our optimization.
  20.  
  21. : I@    postpone i  postpone @   ;    immediate
  22. : IW@    postpone i  postpone w@  ;    immediate
  23. : IC@    postpone i  postpone c@  ;    immediate
  24.  
  25. : I!    postpone i  postpone !   ;    immediate
  26. : IW!    postpone i  postpone w!  ;    immediate
  27. : IC!    postpone i  postpone c!  ;    immediate
  28.  
  29. : 8+        8 +  ;
  30. : 2OVER        3 pick 3 pick  ;
  31. : 2SWAP  { n1 n2 n3 n4 -- n3 n4 n1 n2 }  n3 n4 n1 n2  ;
  32. : -DUP        ?dup  ;
  33. : PICK        hide  1- pick  ;
  34.  
  35. : 2@ dup @ swap 4 + @ ;
  36. : 2! swap over 4 + ! dup drop ! ;
  37.  
  38.  
  39. : <SUPER    postpone super(  ;    immediate
  40. : <INDEXED    indexed  ;
  41.  
  42. : COMPILE    postpone postpone  ;    immediate
  43. : [COMPILE]    postpone postpone  ;    immediate    \ Believe it or not!
  44.  
  45. : 'C    state
  46.     IF
  47.         postpone [']
  48.     ELSE
  49.         '
  50.     THEN  ;        immediate
  51.  
  52. : '    postpone 'c  ;    immediate
  53.  
  54. : CFA  ;
  55. : PFA    >body  ;
  56.  
  57. : CREATE    colHdr  ;
  58.  
  59. : PUSHD0    $ 2D00 w,  ;    immediate    \    move.l    d0,-(a6)
  60. : PUSHA0    $ 2D08 w,  ;    immediate    \    move.l    a0,-(a6)
  61. : POPD0    $ 201E w,  ;    immediate    \    move.l    (a6)+,d0
  62. : POPA0    $ 205E w,  ;    immediate    \    move.l    (a6)+,a0
  63.  
  64. : NEXT,    $ 4E75 w,  ;        \ RTS
  65.  
  66. : <[    postpone [  ;    immediate
  67. : ]>    postpone ]  ;    immediate
  68.  
  69.  
  70. handle    TempH
  71. ptr        TempP
  72.  
  73. : getHSize    \ ( hdl -- size )
  74.     put: tempH  size: tempH  ;
  75.  
  76. : setHSize    \ ( hdl size -- )
  77.     swap put: tempH  setSize: tempH  ;
  78.  
  79. : NEWHANDLE    \ ( size -- hdl )
  80.     new: tempH  get: tempH  ;
  81.  
  82. : NEWPTR    \ ( size -- ptr )
  83.     new: tempP  get: tempP  ;
  84.  
  85. : KILLHANDLE
  86.     put: tempH  release: tempH  ;
  87.  
  88. : DISPOSE
  89.     put: tempP  release: tempP  ;
  90.  
  91.  
  92. \ This stuff allows Neon pointer type objects in Mops to allow a programmer
  93. \ to choose whether to use handle type objects after the conversion to
  94. \ Mops is complete.
  95.  
  96.     handle newObjVar    \ temporary handle to create new obj a la Mops
  97.  
  98. : >heap { ^class \ objHdl objLen -- ^obj }
  99.  
  100.     \ pinched from NEWOBJ:, but save obj length for erase
  101.     ^class cl>len 8 + dup -> objLen new: newObjVar
  102.  
  103.     moveHi: newObjVar            \ debatable
  104.     get: newObjVar -> objHdl    \ save handle
  105.     
  106.     ptr: newObjVar objLen erase    \ clear it like Neon
  107.  
  108.     \ let mops do its thing
  109.     ^class obj: newObjVar make_obj
  110.  
  111.     \ do not unlock, cannot use newObjVar
  112.     \ as classinit: may cause >heap to be re-entered
  113.     objHdl @ ( stripAddr ) 8 +
  114. ;
  115.  
  116. : >dispose ( ^obj -- )
  117.     8 - popA0 call RecoverHandle pushA0
  118.     ?dup if    killHandle then
  119. ;
  120.  
  121.  
  122. : +BASE  ;
  123. : -BASE  ;
  124.  
  125. : (ABS)        ^base  ;
  126.  
  127. \ Conditionals
  128.  
  129. : LAND    0<> swap 0<>  and  negate  ;
  130. : LOR    0<> swap 0<>  or   negate  ;
  131. : LXOR    0<> swap 0<>  xor  negate  ;
  132.  
  133. : =    hide  postpone =   postpone negate  ;    immediate
  134. : <>    hide  postpone <>  postpone negate  ;    immediate
  135. : <    hide  postpone <   postpone negate  ;    immediate
  136. : <=    hide  postpone <=  postpone negate  ;    immediate
  137. : >    hide  postpone >   postpone negate  ;    immediate
  138. : >=    hide  postpone >=  postpone negate  ;    immediate
  139. : 0=    hide  postpone 0=  postpone negate  ;    immediate
  140. : 0>    hide  postpone 0>  postpone negate  ;    immediate
  141. : 0>=    hide  postpone 0>= postpone negate  ;    immediate
  142. : 0<    hide  postpone 0<  postpone negate  ;    immediate
  143. : 0<=    hide  postpone 0<= postpone negate  ;    immediate
  144. : 0<>    hide  postpone 0<> postpone negate  ;    immediate
  145.  
  146. : NOT    0=  ;
  147.  
  148. : f=    hide  postpone f=   postpone negate  ;    immediate
  149. : f<>    hide  postpone f<>  postpone negate  ;    immediate
  150. : f<    hide  postpone f<   postpone negate  ;    immediate
  151. : f<=    hide  postpone f<=  postpone negate  ;    immediate
  152. : f>    hide  postpone f>   postpone negate  ;    immediate
  153. : f>=    hide  postpone f>=  postpone negate  ;    immediate
  154.  
  155. : f0=    hide  postpone f0=  postpone negate  ;    immediate
  156. : f0>    hide  postpone f0>  postpone negate  ;    immediate
  157. : f0<    hide  postpone f0<  postpone negate  ;    immediate
  158.  
  159. : *    *L ;
  160.  
  161. : D=    rot = rot rot = and ;
  162.  
  163.  
  164. : CLASSERR"    postpone ?error  ;    immediate
  165.  
  166. : ?isObj    obj?  ;
  167.  
  168. : >UC        upper  ;
  169.  
  170. : SYSPAT    hide  sysPat get: [ ]  ;
  171.  
  172.  
  173. :class  VAR    hide    <super var
  174.  
  175. \ ( -- ^obj ) get contents as an object  pointer
  176. :M  OBJ:    ^base @  dup 0= classErr" 157  ;M    \ invalid obj addr
  177. :M  DISPOSE:    ^base @  >dispose clear: self ;M    \ dispose of heap ptr
  178. :M  EXEC:    ^base @  dup 0= classErr" 131  execute  ;M
  179. :M  =:        ^base @ swap !  ;M            \ r to l assignment to address
  180. ;class
  181.  
  182. :class  MENU    hide    <super menu
  183.  
  184. \ ( resID -- )  store menuID
  185. :M  INIT:  put: resID  ;M
  186.  
  187. \ ( cfa0...cfaN resid -- )  put resid and handlers in menu
  188. :M  PUT:  Put: ResId limit: self Put: Super  ;M
  189.  
  190. \ ( item# -- addr len )  get string for item #
  191. :M  GET:  { item -- addr len } get: mhndl  item 1+ makeInt
  192.     buf255 +base  call GetItem  buf255 count ;M
  193.  
  194. \ ( item# -- )
  195. :M delete:  Get: Mhndl swap makeInt call delMenuItem ;M
  196.  
  197. \ ( item# addr len -- )
  198. :M SET:  putitem: super  ;M
  199.  
  200. \ ( item# -- )  Enable a menu item
  201. :M  ENABLE:  Get: Mhndl swap makeInt call EnableItem ;M
  202.  
  203. \ ( item# -- )  Grey and disable an item
  204. :M  DISABLE: Get: Mhndl swap makeInt call DisableItem ;M
  205.  
  206. ;class
  207.  
  208. :class  DIALOG    hide    <super dialog
  209.  
  210. :m ACTIONS:    limit actions: super ;M
  211. :m HANDLE:    itemHandle: super ;m
  212. :m INIT:    put: resID  ;m
  213. :m GET:        getitem: super  ;m
  214. :m PUT:        putitem: super  ;m
  215. :m HILITE:    setBold: super  ;m
  216.  
  217. ;class
  218.  
  219. :class    ARRAY    hide    <super array
  220.  
  221. :m PUT:        idxbase limit 4* bounds ?DO i ! 4 +LOOP ;M
  222. :m DISPOSE:         \ ( item# -- )
  223.     ^elem @ >dispose  ;m
  224.  
  225. ;class
  226.  
  227. :CLASS x-Array hide <Super x-Array
  228.     :M  put:    limit put: super ;M
  229.     :M  actions:    limit actions: super ;M
  230. ;CLASS
  231.  
  232. :CLASS window hide <Super window
  233.     :M actions:    4 actions: super ;M
  234.     :M zoom: ( code -- )    drop ;M
  235. ;CLASS
  236.  
  237.  
  238. \ String needs to be redefined with the Neon method names that are different
  239. \ from Mops.
  240.  
  241.  
  242. :CLASS  BasicStr  <Super Handle
  243.  
  244.     Var    offset
  245.  
  246.     \ this method returns the handle - replaces get: in super
  247.     :M  HANDLE:  get: super  ;M
  248.  
  249.     \ interface method to the Toolbox Munger utility
  250.     :M  REPLACE: { addr1 len1 addr2 len2 -- offs }  0
  251.         get: super get: offset dup 0< classErr" 151
  252.         addr1 dup IF +base THEN len1 addr2 dup IF +base THEN len2
  253.         trap$ a9e0 ( call Munger ) put: offset  ;M
  254.  
  255.     \ allocate the string on the heap
  256.     :M  NEW:  0 new: super  clear: offset  ;M
  257.  
  258.     \ set the string to the null string
  259.     :M  CLEAR:  0 setSize: self  clear: offset  ;M
  260.  
  261.     \ ( offs -- ) set new offset for string
  262.     :M  MOVETO:  size: self  min put: offset  ;M
  263.  
  264.     \ ( -- addr len )  return the entire string
  265.     :M  GET:  ptr: self size: self  ;M
  266.  
  267.     \ ( -- addr len )  map string to upper case and get it
  268.     :M  UC:  get: self over +base over >uc   ;M
  269.  
  270.     \ ( addr len -- )  replace entire string with replacement string
  271.     :M  PUT: { addr len -- }   clear: offset
  272.         0 -1 addr len replace: self   ;M
  273.  
  274.     :M  INSERT:  { addr len -- }  addr 0 addr len  replace: self  ;M
  275.  
  276.     :M  ADD: { addr len -- }  64000 moveto: self
  277.         addr len  insert: self ;M
  278.  
  279.     \ ( char -- )  append a char to end of string
  280.     :M  +:  pad c! pad 1 add: self  ;M
  281.  
  282.     \ ( -- chr t OR f)  return char at offset and advance - false if at end
  283.     :M  NEXT:  get: offset size: self <
  284.         IF  get: offset ptr: self + c@ true 1 +: offset
  285.         ELSE  false
  286.         THEN   ;M
  287.  
  288.     \ ( -- )
  289.     :M  PRINT:  get:  self type  ;M
  290.  
  291. ;CLASS
  292.  
  293.  
  294. \ String is a dynamic heap based string object that can grow and shrink
  295.  
  296. :CLASS String  <Super BasicStr
  297.  
  298.     \ ( -- offs ) return the current offset
  299.     :M  WHERE:  get: offset ;M
  300.  
  301.     \ move to the 0th byte in the string
  302.     :M  START:  0 moveTo: self ;M
  303.  
  304.     \ assign this string to any object that accepts addr len
  305.     :M  =: { theObj -- }  get: self put: theObj ;M
  306.  
  307.     \ ( chr len -- )  clear the string and set it to len bytes of chr
  308.     :M  FILL:   buf255 swap put: self    \ use put with arbitrary data
  309.         get: self rot Fill ;M
  310.  
  311.     \ name an object using this string
  312.     :M  NAME=: { theObj -- }  get: self  name: theObj ;M
  313.  
  314.     \ ( len -- )  return the substring starting at offset
  315.     :M  SUBSTR: { len -- addr len } get: offset 0< classErr" 151
  316.         ptr: self  get: offset +
  317.         size: self  get: offset -  len min  0 max ;M
  318.  
  319.     :M  DELETE:  { addr len -- }  addr len addr 0 replace: self ;M
  320.  
  321.     :M  INDEXOF: { addr len -- offs }  addr len 0 0 replace: self
  322.         get: offset dup 0<
  323.         IF  drop false
  324.         ELSE true
  325.         THEN ;M
  326.  
  327.     \ ( char -- offs t OR f )  find a single character in the string
  328.     :M  CHAROF:  pad c! pad 1 indexof: self ;M
  329.  
  330.     \ ( ^fcb -- rc )  Fill string from file object
  331.     :M  READ:  { theFcb len -- rc }  len setsize: self
  332.         get: self  read: thefcb
  333.         bytesRead: thefcb  setSize: self ;M
  334.  
  335.     \ ( ^fcb -- rc )  Fill string from file object
  336.     :M  READLINE:  { theFcb len -- rc }  len setSize: self
  337.         get: self  readLine: thefcb
  338.         bytesRead: thefcb  setSize: self ;M
  339.  
  340.     \ ( rect just -- )  draw string justified in rect
  341.     :M  DRAW:  { tRect just -- } ptr: self +base  size: self
  342.         tRect +base just makeInt trap$ a9ce  ( call TextBox ) ;M
  343.  
  344. ;CLASS
  345.